home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / disk-cache-inspector.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  7.1 KB  |  188 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: WOOD -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; disk-cache-inspector.lisp
  6. ;; Inspector interface for the disk-cache data file.
  7. ;; This code is as gross as it is because format is so slow.
  8. ;;
  9. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  10. ;; Permission is given to use, copy, and modify this software provided
  11. ;; that this copyright notice is attached to all derivative works.
  12. ;; This software is provided "as is". Apple makes no warranty or
  13. ;; representation, either express or implied, with respect to this software,
  14. ;; its quality, accuracy, merchantability, or fitness for a particular
  15. ;; purpose.
  16. ;;
  17.  
  18. ;; A disk-cache inspects the normal way, but has a command that
  19. ;; brings up a contents editor.
  20. ;; While in the contents editor, you can move to any address
  21. ;; with a command, you can control-click or double-click to
  22. ;; move to a pointed-to address and set @, and you can option-click
  23. ;; to just set @ to the pointed at value.
  24. ;; The commands menu remembers the last two addresses visited.
  25.  
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. ;;
  28. ;; Modification History
  29. ;;
  30. ;; 03/18/92 bill New file
  31. ;;
  32.  
  33. (In-package :wood)
  34.  
  35. (defclass disk-cache-inspector (inspector::usual-object-first-inspector) ())
  36.  
  37. ; True to bring up the contents editor by default instead of the structure editor.
  38. (defparameter *inspect-disk-cache-data* t)
  39.  
  40. (defmethod inspector::inspector-class ((object disk-cache))
  41.   (if *inspect-disk-cache-data*
  42.     'disk-cache-inspector
  43.     (call-next-method)))
  44.  
  45. (defclass disk-cache-inspector-view (inspector::inspector-view)
  46.   ((last-address :initform nil :accessor last-address)
  47.    (current-address :initform nil :accessor current-address))
  48.   (:default-initargs :cache-p nil))
  49.  
  50. (defmethod inspector::inspector-view-class ((in disk-cache-inspector))
  51.   'disk-cache-inspector-view)
  52.  
  53. (defmethod inspector::compute-line-count ((in disk-cache-inspector))
  54.   (floor (+ (disk-cache-size (inspector::inspector-object in)) 15) 16))
  55.  
  56. (defun encode-hex (value string index digits)
  57.   (unless (and (simple-string-p string)
  58.                (fixnump index)
  59.                (fixnump digits)
  60.                (>= index 0)
  61.                (<= (the fixnum (+ index digits)) (length string))
  62.                (fixnump value))
  63.     (error "You lose."))
  64.   (%encode-hex value string index digits))
  65.  
  66. (defconstant *hex-digits* "0123456789ABCDEF")
  67.  
  68. (defun %encode-hex (value string index digits-left)
  69.   (declare (optimize (speed 3 safety 0)))
  70.   (declare (fixnum pos digits-left value))
  71.   (if (eql digits-left 0)
  72.     index
  73.     (let ((r (logand value #xf))
  74.           (q (ash value -4)))
  75.       (declare (fixnum r q))
  76.       (let ((i (%encode-hex q string index (the fixnum (1- digits-left)))))
  77.         (setf (schar string i) (schar *hex-digits* r))
  78.         (the fixnum (1+ i))))))
  79.  
  80. (defparameter *disk-cache-inspector-string*
  81.   (make-string 16))
  82. (defparameter *disk-cache-inspector-value*
  83.   (make-string (+ 8 2 8 1 8 1 8 1 8 2 16 2) :initial-element #\space))
  84.  
  85. (defmethod inspector::line-n ((in disk-cache-inspector) n)
  86.   (let* ((disk-cache (inspector::inspector-object in))
  87.          (address (* n 16))
  88.          (size (disk-cache-size disk-cache))
  89.          (string *disk-cache-inspector-string*)
  90.          (value *disk-cache-inspector-value*))
  91.     (let ((count (min 16 (- size address))))
  92.       (read-string disk-cache address count string)
  93.       (do ((i count (1+ i)))
  94.           ((>= i 16))
  95.         (declare (fixnum i))
  96.         (setf (schar string i) (code-char 0))))
  97.     (encode-hex address value 0 8)
  98.     (setf (schar value 8) #\:)
  99.     (let ((index 10)
  100.           (word -1))
  101.       (declare (fixnum index word))
  102.       (dotimes (i 4)
  103.         (encode-hex (ccl::%typed-uvref ccl::$v_uwordv string (incf word))
  104.                     value index 4)
  105.         (encode-hex (ccl::%typed-uvref ccl::$v_uwordv string (incf word))
  106.                     value (incf index 4) 4)
  107.         (incf index 5))
  108.       (setf (schar value (incf index)) #\")
  109.       (dotimes (i 16)
  110.         (let ((char (schar string i)))
  111.           (declare (character char))
  112.           (setf (schar value (incf index))
  113.                 (if (graphic-char-p char) char #\.))))
  114.       (setf (schar value (incf index)) #\")
  115.       (values value
  116.               nil
  117.               :static))))
  118.  
  119. (defmethod inspector::prin1-value ((i disk-cache-inspector) stream value
  120.                                    &optional label type)
  121.   (declare (ignore label type))
  122.   (if (stringp value)
  123.     (stream-write-string stream value 0 (length value))
  124.     (call-next-method)))
  125.  
  126. (defmethod inspector::inspect-selection ((v disk-cache-inspector-view))
  127.   (let ((selection (inspector::selection v)))
  128.     (if (eql 0 selection)
  129.       (call-next-method)
  130.       (let ((address (* (1- selection) 16))
  131.             (h (point-h (view-mouse-position v))))
  132.         (multiple-value-bind (ff ms) (view-font-codes v)
  133.           (let* ((w (nth-value 2 (font-codes-info ff ms)))
  134.                  (char (round h w))
  135.                  (word (floor (- char 10) 9))
  136.                  (dc (inspector::inspector-object v))
  137.                  (new-address (cond ((< word 0) address)
  138.                                     ((> word 3) (ed-beep) (cancel))
  139.                                     (t (read-unsigned-long dc (+ address (* word 4)))))))
  140.             (if (option-key-p)
  141.               (setq @ new-address)
  142.               (progn
  143.                 (when (> new-address (disk-cache-size dc))
  144.                   (ed-beep) (cancel))
  145.                 (scroll-to-address v new-address)))))))))
  146.  
  147. (defmethod inspector::inspector-commands ((dc disk-cache))
  148.   `(("Inspect contents"
  149.      ,#'(lambda () (let ((*inspect-disk-cache-data* t))
  150.                      (inspect dc))))))
  151.  
  152. (defmethod inspector::inspector-commands ((in disk-cache-inspector))
  153.   (let ((view (inspector::inspector-view in)))
  154.     `(("Inspect struct"
  155.      ,#'(lambda () (let ((*inspect-disk-cache-data* nil))
  156.                      (inspect (inspector::inspector-object in)))))
  157.       ("Go to address..."
  158.        ,#'(lambda ()
  159.             (let ((address (let ((*read-base* 16))
  160.                              (read-from-string
  161.                               (get-string-from-user "Enter an address (hex):")))))
  162.               (if (integerp address)
  163.                 (scroll-to-address view address)))))
  164.       ,@(let ((last-address (last-address view)))
  165.           (when last-address
  166.             `((,(format nil "Go to address #x~x" last-address)
  167.                ,#'(lambda ()
  168.                     (scroll-to-address view last-address))))))
  169.       ,@(let ((current-address (current-address view)))
  170.           (when current-address
  171.             `((,(format nil "Go to address #x~x" current-address)
  172.                ,#'(lambda ()
  173.                     (scroll-to-address view current-address)))))))))
  174.  
  175. (defmethod scroll-to-address ((v disk-cache-inspector-view) address)
  176.   (setf (last-address v) (current-address v))
  177.   (setf (current-address v) address)
  178.   (setq @ address)
  179.   (let* ((inspector (inspector::inspector v))
  180.          (dc (inspector::inspector-object inspector)))
  181.     (inspector::scroll-to-line
  182.      v
  183.      (1+ (floor (min (disk-cache-size dc) address) 16))
  184.      nil
  185.      0)
  186.     (unless (eql (inspector::compute-line-count inspector)
  187.                  (inspector::inspector-line-count inspector))
  188.       (inspector::resample v))))